perm filename CHS3.F4[1,VDS] blob
sn#109561 filedate 1974-07-03 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00024 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 C MAIN PROGRAM -- 'LOOK-UP'
C00018 00003 SUBROUTINE OUTPUT (SKIP)
C00030 00004 SUBROUTINE UPDATE
C00035 00005 SUBROUTINE MESAGE
C00038 00006 SUBROUTINE RESET
C00041 00007 SUBROUTINE CLEARS
C00043 00008 SUBROUTINE SETUP (*)
C00050 00009 SUBROUTINE CLEAR
C00055 00010 SUBROUTINE RPAREN
C00057 00011 SUBROUTINE EQUAL
C00059 00012 SUBROUTINE SIGN
C00062 00013 SUBROUTINE ABSFCN
C00065 00014 SUBROUTINE EXECUT (*)
C00071 00015 SUBROUTINE CLEARX
C00074 00016 SUBROUTINE ENTRY
C00079 00017 SUBROUTINE DIGIT
C00083 00018 SUBROUTINE DECPT
C00086 00019 SUBROUTINE CORECT
C00089 00020 SUBROUTINE RECALL
C00093 00021 SUBROUTINE STORE
C00096 00022 SUBROUTINE REG (RN)
C00098 00023 SUBROUTINE FINDN (K, KMAX, RN)
C00102 00024 SUBROUTINE FIXN
C00105 ENDMK
C⊗;
C MAIN PROGRAM -- 'LOOK-UP'
C DATE OF LAST CHANGE - 740620
IMPLICIT INTEGER (A-Z)
REAL Y
REAL*8 DATE
LOGICAL START,READ,NEXT,FIXFLG
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
10 DO 20 I=2,21
DO 20 J=1,17
R(I,J)=0
20 R(I,2)=15
R(21,1)=15
R(21,2)=1
R(21,3)=5
R(21,17)=1
C *** REGISTERS ARE ALLOCATED AS FOLLOWS: R(1)="PI", R(2)="A",
C R(3)="LST X", R(4)="LST Y", R(5)="R0", ..., R(20)="R15",
C R(21)="HIGHEST REG NO. AVAILABLE"
C
C SIZE = NO. OF KEYS ON KEYBOARD (SEE DECODER BELOW)
SIZE=39
C *** CONTROL PARAMETERS
C NEQNS = NO. OF TESTS TO BE RUN
C READ = SWITCH FOR INPUT MODE (F = RANDOM)
C SWITCH = OUTPUT CONTROL (0 -> NORMAL, 1 -> SHORT)
C FIXFLG = 'DISPLAY' CONTROL (T = FIX MODE)
C FIX = NUMBER OF DECIMAL DIGITS IN FIX MODE (0-9)
C SCI = NUMBER OF DECIMAL DIGITS IN SCI MODE (0-9)
C DATE = DATE OF RUN ('MO/DY/YR')
C NKEYS = NO. OF KEY-STROKES PER TEST
C IY = RANDOM NO.
C
NEQNS=100
C- READ=.TRUE.
SWITCH=2
FIXFLG=.TRUE.
FIX=2
SCI=5
C
TYPE 1000
ACCEPT 1011, START
IF (START) GO TO 40
TYPE 1001
ACCEPT 1012, NEQNS
C- TYPE 1002
C- ACCEPT 1011, READ
C- READ=.NOT.READ
C- IF (READ) GO TO 30
C- TYPE 1003
C- ACCEPT 1013, NKEYS, IY
30 TYPE 1004
ACCEPT 1012, SWITCH
TYPE 1008
ACCEPT 1011, START
IF (START) GO TO 40
TYPE 1009
ACCEPT 1011, FIXFLG
TYPE 1010
ACCEPT 1013, FIX, SCI
C CONSIDER 'NEQNS' EQUATIONS
40 DO 320 TEST=1,NEQNS
ERROR=0
OLD=1
DO 50 II=1,50
INPUT(II)=15
50 EXPR(II)=15
CALL CLEAR
TYPE 1015, TEST
C- IF (READ) GO TO 90
C- 60 DO 80 II=1,NKEYS
C- 70 CALL RANDOM (IY, Y, 0)
C- JJ=(SIZE-1)*Y+1.5
C- IF (JJ.EQ.15.OR.JJ.EQ.29.OR.JJ.EQ.30) GO TO 70
C- 80 INPUT(II)=JJ
90 CALL OUTPUT (-1)
KEY=0
C OBTAIN NEXT KEY-CODE
100 CALL CONTRL
C DECODE KEY-CODE
110 IF (NEXT) NEXT=.FALSE.
IF (CODE.LE.12 .OR. CODE.EQ.28) GO TO 130
IF (CODE.EQ.13.OR.CODE.EQ.14) GO TO 140
IF (CODE.GT.15.AND.CODE.LT.20.AND.CODE.NE.18) GO TO 150
IF (CODE.EQ.18) GO TO 160
IF (CODE.EQ.20) GO TO 170
IF (CODE.EQ.22) GO TO 180
IF (CODE.GT.22.AND.CODE.LT.26 .OR.
* CODE.EQ.38 .OR. CODE.EQ.39) GO TO 190
IF (CODE.EQ.26) GO TO 200
IF (CODE.EQ.27) GO TO 210
IF (CODE.EQ.21) GO TO 220
IF (CODE.EQ.31) GO TO 230
IF (CODE.EQ.32) GO TO 240
IF (CODE.EQ.33) GO TO 250
IF (CODE.EQ.34) GO TO 260
IF (CODE.EQ.35) GO TO 270
IF (CODE.EQ.36 .OR. CODE.EQ.37) GO TO 280
IF (CODE.EQ.15.OR.CODE.EQ.29.OR.CODE.EQ.30) GO TO 300
IF (CODE.EQ.99) GO TO 320
IF (CODE.EQ.999) GO TO 10
IF (CODE.GT.SIZE) GO TO 120
C KEY-CODE ERROR
120 ERROR=17
GO TO 280
C CALL KEY ROUTINE
130 CALL ENTRY
GO TO 280
140 CALL SIGN
GO TO 280
150 CALL MULT
GO TO 280
160 CALL LPAREN
GO TO 280
170 CALL RPAREN
GO TO 280
180 CALL EQUAL
GO TO 280
190 CALL RECALL
GO TO 280
200 CALL CLEAR
GO TO 280
210 CALL CLEARX
GO TO 280
220 CALL ABSFCN
GO TO 280
230 CALL STORE
GO TO 280
240 CALL FIXN
GO TO 280
250 CALL SCIN
GO TO 280
260 CALL IMEDEX
GO TO 280
270 CALL EXCH
C PRINT EXPRESSION, STACK, VARIABLES
280 IF (ERROR.NE.0) CALL MESAGE
290 IF (ERROR.NE.0) GO TO 310
300 IF (KEY.LT.NKEYS) GO TO 100
GO TO 320
310 TYPE 1016
320 CONTINUE
STOP
1000 FORMAT (///' THE STANDARD CONTROL SETTINGS ARE:'
* /' EXIT AFTER 100 EQUATIONS'
* /' PRODUCE ''DISPLAY'' OUTPUT'
* /' DISPLAY IN FIX MODE W/ FIX=2 & SCI=5'
* //' THESE ARE OKAY. (T OR F)'/)
C-↑ * /' ACCEPT KEYSTROKES FROM TTY'
1001 FORMAT (/' HOW MANY EQUATIONS ARE YOU GOING TO TRY? (NN)'/)
C1002 FORMAT (/' THE KEYSTROKES ARE TO BE GENERATED RANDOMLY.',
C- * ' (T OR F)'/)
C1003 FORMAT (/' ENTER THE NUMBER OF KEYSTROKES TO BE GENERATED '
C- * /' AND AN INITIAL RANDOM NUMBER. (NN <SP> MM)'/)
1004 FORMAT (/' ENTER CODE FOR DESIRED OUTPUT: 0 = LONG'/32X,
* ' 1 = SHORT'/33X,'2 = DISPLAY ONLY'/)
1008 FORMAT (/' THE STANDARD DISPLAY SETTINGS ARE WANTED.',
* ' (T OR F)'/)
1009 FORMAT (/' FIX MODE DISPLAY IS WANTED INITIALLY. (T OR F)'/)
1010 FORMAT (/' ENTER NUMBER OF DECIMAL DIGITS DESIRED IN FIX'
* /' AND SCI MODES, RESPECTIVELY. (N <SP> M)'/)
1011 FORMAT (L1)
1012 FORMAT (I)
1013 FORMAT (2I)
1015 FORMAT ('1 TEST NO.',I3/)
1016 FORMAT (/' ATTEMPT TO ENTER KEY WHILE IN ERROR CONDITION',
* ' HAS TERMINATED THIS EQUATION'/)
END
C
C
C
C
C
C
C
C
C
C
BLOCK DATA
C DATE OF LAST CHANGE - 740310
IMPLICIT INTEGER (A-Z)
LOGICAL JUMP, NEXT, FIXFLG, READ
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DATA P /6*0/, OP /6*0/, D /16*13/, X /102*13/,
* JUMP, NEXT /2*.FALSE./, NKEYS /100/,
* R(1,1),R(1,2),R(1,3),R(1,4),R(1,5),R(1,6),R(1,7),R(1,8),
* R(1,9),R(1,10),R(1,11),R(1,12),R(1,13),R(1,14),R(1,15),
* R(1,16),R(1,17) /15,3,1,4,1,5,9,2,6,5,3,5,9,0,15,0,0/
END
SUBROUTINE OUTPUT (SKIP)
C DATE OF LAST CHANGE - 740310
IMPLICIT INTEGER (A-Z)
INTEGER*2 CHAR(39), STROKE(50), SIGN(6), ESN(6),
* DISPLY(16), REG(17)
LOGICAL EEX, DP, START, FIXFLG
REAL*8 NAME(3)
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
2 /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
3 /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
4 /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DATA CHAR( 1),CHAR( 2),CHAR( 3),CHAR( 4)/' 1',' 2',' 3',' 4'/,
2 CHAR( 5),CHAR( 6),CHAR( 7),CHAR( 8)/' 5',' 6',' 7',' 8'/,
3 CHAR( 9),CHAR(10),CHAR(11),CHAR(12)/' 9',' 0',' .','EE'/,
4 CHAR(13),CHAR(14),CHAR(15),CHAR(16)/' -',' +',' ',' /'/,
5 CHAR(17),CHAR(18),CHAR(19),CHAR(20)/' *',' (','**',' )'/,
6 CHAR(21),CHAR(22),CHAR(23),CHAR(24)/'AB',' =',' A','PI'/,
7 CHAR(25),CHAR(26),CHAR(27),CHAR(28)/' R','CL','CX','CO'/,
8 CHAR(29),CHAR(30),CHAR(31),CHAR(32)/' E','SV','->','FX'/,
9 CHAR(33),CHAR(34),CHAR(35),CHAR(36)/'SN','IX','XC',' ;'/,
A CHAR(37),CHAR(38),CHAR(39) /' ,','LX','LY'/
DATA NAME /' A =', 'LAST X =','LAST Y ='/
C VARIOUS VALUES OF 'SKIP' GIVE: -1 → EXPRESSION
C 0 → LONG OUTPUT
C 1 → SHORT OUTPUT
C 2 → DISPLAY ONLY
IF (SKIP.LT.0) GO TO 30
10 DO 20 I=OLD,KEY
J=EXPR(I)
IF (J.EQ.0) J=10
20 STROKE(I)=CHAR(J)
TYPE 1000, (STROKE(I),I=1,KEY)
OLD=KEY+1
IF (SKIP.EQ.2) GO TO 70
GO TO 50
30 DO 40 I=1,50
40 STROKE(I)=CHAR(15)
TYPE 1000, STROKE(1)
50 DO 60 I=1,6
J=X(I,1)
IF (J.EQ.0) J=15
SIGN(I)=CHAR(J)
K=X(I,15)
IF (K.EQ.0) K=15
60 ESN(I)=CHAR(K)
70 DO 80 I=1,16
J=D(I)
IF (J.EQ.0) J=10
80 DISPLY(I)=CHAR(J)
IF (SKIP.EQ.2) GO TO 100
IF (SKIP.EQ.1) GO TO 90
TYPE 2000, START, L, DP, M, EEX, FIX, FIXFLG, SCI, ERROR
TYPE 3000, P(6),SIGN(6),(X(6,N),N=2,14),ESN(6),X(6,16),
2 X(6,17),OP(6),P(5),SIGN(5),(X(5,N),N=2,14),
3 ESN(5),X(5,16),X(5,17),OP(5),P(4),SIGN(4),
4 (X(4,N),N=2,14),ESN(4),X(4,16),X(4,17),OP(4),
5 P(3),SIGN(3),(X(3,N),N=2,14),ESN(3),X(3,16),
6 X(3,17),OP(3)
90 TYPE 4000, P(2),SIGN(2),(X(2,N),N=2,14),ESN(2),X(2,16),
2 X(2,17),OP(2),P(1),SIGN(1),(X(1,N),N=2,14),
3 ESN(1),X(1,16),X(1,17),OP(1)
100 TYPE 5000, DISPLY
IF (SKIP.EQ.2) RETURN
DO 120 I=2,4
IF (R(I,2).EQ.15) GO TO 120
DO 110 J=1,17
K=R(I,J)
IF (K.EQ.0) K=10
110 REG(J)=CHAR(K)
TYPE 6000, NAME(I-1), (REG(N), N=1,17)
120 CONTINUE
DO 140 I=5,20
IF (R(I,2).EQ.15) GO TO 140
J=I-5
DO 130 K=1,17
KK=R(I,K)
IF (KK.EQ.0) KK=10
130 REG(K)=CHAR(KK)
TYPE 7000, J, (REG(N), N=1,17)
140 CONTINUE
RETURN
1000 FORMAT (/6X,'EXPRESSION: ',39A3/30X,11A3)
2000 FORMAT (//14X,'FLAGS: START - ',L2,20X,'INDICES: L -',
2 I2/22X,'DP - ',L2,30X,'M -',I2/22X,
3 'EEX - ',L2,30X,'FIX -',I2/22X,'FIXFLG- ',L2,
4 30X,'SCI -'I2/62X,'ERROR -',I2)
3000 FORMAT (//14X,'STACK: S(6) -',4X,I2,' / ',A2,I2,' .',12I2,
2 A2,2I2,' /',I3/22X,'S(5) -',4X,I2,' / ',A2,I2,' .',
3 12I2,A2,2I2,' /',I3/22X,'S(4) -',4X,I2,' / ',A2,I2,
4 ' .',12I2,A2,2I2,' /',I3/22X,'S(3) -',4X,I2,' / ',
5 A2,I2,' .',12I2,A2,2I2,' /',I3)
4000 FORMAT (/22X,'S(2) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,' /',
2 I3/22X,'S(1) -',4X,I2,' / ',A2,I2,' .',12I2,A2,2I2,
3 ' /',I3/)
5000 FORMAT (/14X,'DISPLAY:',9X,16A3///)
6000 FORMAT (15X,A8,1X,2A3,' .',15A3)
7000 FORMAT (14X,'REG(',I2,') =',1X,2A3,' .',15A3)
END
C
C
C
C
C
C
C
C
C
C
C- SUBROUTINE RANDOM (IY, Y, INDEX)
C- IY=IY*314159269+453806245
C- IF (IY.LT.0) IY=IY+2147483647+1
C- Y=IY
C- Y=Y*4.656613E-10
C- RETURN
C- END
SUBROUTINE UPDATE
C DATE OF LAST CHANGE - 740209
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (X(1,2).GT.15) RETURN
D(1)=X(1,1)
IF (D(1).EQ.14) D(1)=15
D(2)=X(1,2)
IF (X(1,2).EQ.15) D(2)=0
IF (D(1).EQ.13 .AND. D(2).EQ.0) D(1)=15
IF (.NOT.FIXFLG) GO TO 12
C DISPLAY IN "FIX" FORMAT
IF (X(1,16).GT.0) GO TO 12
EXPX=X(1,17)
IF (X(1,15).EQ.13) GO TO 5
K=EXPX+FIX+1
IF (K.GT.10) GO TO 12
DO 1 I=13,16
1 D(I)=15
CALL ROUND (K)
K=EXPX+2
DO 2 I=3,K
2 D(I)=W(I)
K=K+1
D(K)=11
IF (FIX.EQ.0) GO TO 4
DO 3 I=1,FIX
3 D(I+K)=W(I+K-1)
4 K=K+FIX+1
GO TO 15
5 D(2)=10
D(3)=11
K=FIX-EXPX+1
IF (K.LE.0) GO TO 8
CALL ROUND (K)
J=EXPX+2
DO 6 I=4,J
6 D(I)=10
DO 7 I=1,K
7 D(J+I)=W(I+1)
GO TO 10
8 J=FIX+3
DO 9 I=4,J
9 D(I)=10
10 K=FIX+4
DO 11 I=13,16
11 D(I)=15
GO TO 15
C DISPLAY IN "SCI" FORMAT
12 CALL ROUND (SCI)
D(13)=29
DO 13 I=14,16
13 D(I)=W(I+1)
D(3)=11
K=SCI+3
DO 14 I=5,K
14 D(I-1)=W(I-2)
15 DO 16 I=K,12
16 D(I)=15
RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE ROUND (N)
C DATE OF LAST CHANGE - 740209
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DO 1 I=1,17
1 W(I)=X(1,I)
IF (W(N+2)-5) 6,2,4
2 K=N+3
DO 3 I=K,14
IF (W(I).GT.0) GO TO 4
3 CONTINUE
K=N+1
IF (2*(W(K)/2) .EQ. W(K)) GO TO 6
4 K=N+1
W(K)=W(K)+1
DO 5 I=3,K
J=N+4-I
IF (W(J).LT.10) GO TO 6
W(J)=W(J)-10
5 W(J-1)=W(J-1)+1
6 RETURN
END
SUBROUTINE MESAGE
C DATE OF LAST CHANGE - 740620
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
NEXT=.FALSE.
D(1)=15
DO 1 I=2,16
1 D(I)=13
D(8)=29
D(9)=ERROR/10
D(10)=ERROR-10*D(9)
IF (ERROR.NE.17) GO TO 2
D(15)=CODE/10
D(16)=CODE-10*D(15)
2 CALL CONTRL
IF (CODE.EQ.26) GO TO 3
IF (CODE.NE.27) GO TO 5
CALL UPDATE
GO TO 4
3 CALL CLEAR
4 ERROR=0
5 RETURN
END
C
C
C
C
C
C
SUBROUTINE CONTRL
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION INPUT(50), EXPR(50), R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
1 CALL OUTPUT (SWITCH)
IF (NEXT) RETURN
2 TYPE 4
ACCEPT 5, CODE
IF (CODE.NE.100) GO TO 3
CALL OUTPUT (0)
GO TO 2
3 KEY=KEY+1
EXPR(KEY)=CODE
IF (CODE.EQ.10) CODE=0
RETURN
4 FORMAT (' ?'/)
5 FORMAT (I)
END
SUBROUTINE RESET
C DATE OF LAST CHANGE - 740210
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
DIMENSION R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
L=1
M=1
DP=.FALSE.
EEX=.FALSE.
CALL UPDATE
RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE TESTUP (*)
C DATE OF LAST CHANGE - 740625
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
IF (X(6,2).EQ.15) RETURN
IF (OP(2).LT.50) RETURN 1
IF (P(1).GT.0) RETURN 1
RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE ENTRUP (*)
C DATE OF LAST CHANGE - 740106
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
DO 1 II=1,5
JJ=6-II
KK=JJ+1
P(KK)=P(JJ)
OP(KK)=OP(JJ)
DO 1 LL=1,17
1 X(KK,LL)=X(JJ,LL)
CALL CLEARS
RETURN
END
SUBROUTINE CLEARS
C DATE OF LAST CHANGE - 740310
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
P(1)=0
CALL CLEARX
RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE DROP
C DATE OF LAST CHANGE - 731224
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
P(1)=P(2)
C USUALLY DROP 3 -> 2, ETC.; AFTER 'CLEAR X' DROP 2 -> 1, ETC.
J=2
IF (X(1,2).EQ.15) J=1
DO 1 II=J,5
JJ=II+1
P(II)=P(JJ)
OP(II)=OP(JJ)
DO 1 KK=1,17
1 X(II,KK)=X(JJ,KK)
IF (OP(6).EQ.0) RETURN
OP(6)=0
P(6)=0
DO 2 II=1,17
2 X(6,II)=0
X(6,2)=15
RETURN
END
SUBROUTINE SETUP (*)
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL START
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (.NOT.START) GO TO 1
START=.FALSE.
RETURN
1 IF (X(1,2).EQ.15) RETURN
IF (OP(1).NE.0) GO TO 2
CALL TESTUP (&4)
OP(1)=50
CALL COLAPS (&5)
GO TO 6
2 IF (OP(1).NE.1) GO TO 3
CALL CLEARX
RETURN
3 IF (X(6,2).EQ.15) GO TO 6
4 ERROR=3
5 RETURN 1
6 CALL ENTRUP (&5)
RETURN
END
SUBROUTINE CLEAR
C DATE OF LAST CHANGE - 740625
IMPLICIT INTEGER (A-Z)
LOGICAL START
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (ERROR.NE.0) CALL CLEARX
CALL CLEARS
DO 1 II=2,6
JJ=II-1
P(II)=P(JJ)
OP(II)=OP(JJ)
DO 1 KK=1,17
1 X(II,KK)=X(JJ,KK)
START=.TRUE.
RETURN
END
C
C
C
C
C
C
C
C
C
SUBROUTINE LPAREN
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
LOGICAL START
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (P(1).NE.4) GO TO 1
ERROR=2
RETURN
1 IF (START) GO TO 9
IF (X(1,2).NE.15) GO TO 2
IF (X(1,1).NE.13) GO TO 9
CALL TESTUP (&7)
X(1,2)=1
GO TO 4
2 IF (OP(1).NE.0) GO TO 5
3 CALL TESTUP (&7)
4 OP(1)=50
CALL COLAPS (&10)
GO TO 8
5 IF (OP(1).NE.1) GO TO 6
CALL CLEARX
GO TO 9
6 IF (X(6,2).EQ.15) GO TO 8
7 ERROR=3
RETURN
8 CALL ENTRUP (&10)
9 P(1)=P(1)+1
10 RETURN
END
SUBROUTINE RPAREN
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
LOGICAL START
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (START) GO TO 4
IF (OP(1).EQ.0) GO TO 2
1 ERROR=1
RETURN
2 DO 3 I=1,6
IF (P(I).NE.0) GO TO 5
3 CONTINUE
4 ERROR=4
RETURN
5 IF (P(1).NE.0) GO TO 6
IF (OP(2).EQ.0) GO TO 1
CALL EXECUT (&9)
GO TO 5
6 P(1)=P(1)-1
IF (P(1).NE.0) GO TO 8
IF (X(1,2).NE.15) GO TO 7
IF (OP(2).NE.50) GO TO 8
OP(2)=0
IF (X(1,2).EQ.1) X(1,2)=15
CALL DROP
GO TO 8
7 IF (OP(2).NE.71) GO TO 8
CALL EXECUT (&9)
RETURN
8 CALL UPDATE
9 RETURN
END
SUBROUTINE EQUAL
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (X(1,2).EQ.15) GO TO 1
IF (OP(1).EQ.0) GO TO 2
IF (OP(1).EQ.1) RETURN
1 ERROR=1
RETURN
2 DO 3 I=1,6
IF (P(I).NE.0) GO TO 4
3 CONTINUE
GO TO 5
4 ERROR=4
RETURN
5 IF (OP(2).EQ.0) GO TO 6
CALL EXECUT (&7)
GO TO 2
6 CALL UPDATE
OP(1)=1
7 RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE EXCH
C DATE OF LAST CHANGE - 740620
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
DO 1 I=1,17
W=X(1,I)
X(1,I)=X(2,I)
1 X(2,I)=W
CALL UPDATE
RETURN
END
SUBROUTINE SIGN
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
LOGICAL START
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
IF (OP(1).NE.0) GO TO 2
IF (X(1,2).EQ.15) GO TO 5
1 OP(1)=CODE+17
CALL COLAPS (&6)
CALL UPDATE
RETURN
2 IF (OP(1).EQ.1) GO TO 1
3 IF (X(6,2).EQ.15) GO TO 4
ERROR=3
RETURN
4 CALL ENTRUP (&6)
5 IF ( START) START=.FALSE.
IF (CODE.NE.13) RETURN
IF (X(1,1).EQ.13) D(1)=15
IF (X(1,1).NE.13) D(1)=13
X(1,1)=D(1)
6 RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE MULT
C DATE OF LAST CHANGE - 740604
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (X(1,2).EQ.15) GO TO 1
IF (OP(1).LT.2) GO TO 2
1 ERROR=1
RETURN
2 OP(1)=CODE+24
IF (CODE.EQ.19) OP(1)=60
CALL COLAPS (&3)
CALL UPDATE
3 RETURN
END
SUBROUTINE ABSFCN
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16)
COMMON /STACK/ P, X, OP, D
CALL SETUP (&1)
OP(1)=71
D(1)=15
X(1,2)=21
1 RETURN
END
C
C
C
C
C
C
C
C
C
SUBROUTINE IMEDEX
C DATE OF LAST CHANGE - 740306
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (OP(1).EQ.1) RETURN
IF (OP(1).EQ.0) GO TO 1
IF (X(1,2).EQ.15) GO TO 1
IF (OP(2).EQ.0) GO TO 2
1 ERROR=1
RETURN
2 OP(2)=OP(1)
CALL EXECUT
RETURN
END
C
C
C
C
C
C
C
C
C
SUBROUTINE COLAPS (*)
C DATE OF LAST CHANGE - 740306
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
1 IF (P(1).NE.0) RETURN
IF (OP(1)/10 .GT. OP(2)/10) RETURN
IF (OP(2).NE.0) GO TO 3
ERROR=18
2 RETURN 1
3 CALL EXECUT (&2)
GO TO 1
END
SUBROUTINE EXECUT (*)
C DATE OF LAST CHANGE - 740602
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), A(2,17)
COMMON /STACK/ P, X, OP, D
IF (OP(2).EQ.71) GO TO 3
DO 1 I=1,2
DO 1 J=1,17
1 A(I,J)=X(I,J)
CALL COMBIN (A, OP(2), .TRUE., &5)
DO 2 I=1,17
2 X(1,I)=A(1,I)
GO TO 4
3 IF (X(1,1).EQ.13) X(1,1)=14
IF (X(2,1).EQ.13) X(1,1)=13
4 CALL DROP
CALL UPDATE
RETURN
5 RETURN 1
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE COMBIN (A, OPER, SAVE, *)
C DATE OF LAST CHANGE - 740612
C PURPOSE: EXECUTE "A(2,N) OPER A(1,N) → A(1,N)"
IMPLICIT INTEGER (A-Z)
LOGICAL SAVE
REAL RX(2), X1, ALOG10, ABS, ALOG, EXP, E
DIMENSION P(6), X(6,17), OP(6), D(16),
* R(21,17), W(17), A(2,17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (.NOT.SAVE) GO TO 2
C SAVE X(1,N) IN "LST X" & X(2,N) IN "LST Y"
DO 1 N=1,17
R(3,N)=X(1,N)
1 R(4,N)=X(2,N)
C CONVERT A(I,N) TO RX(I)
2 DO 4 I=1,2
RX(I)=A(I,14)
DO 3 J=1,12
K=14-J
3 RX(I)=0.1*RX(I)+A(I,K)
IF (A(I,1).EQ.13) RX(I)=-RX(I)
J=10.0*A(I,16)+A(I,17)+0.5
IF (J.GT.30) J=30
IF (A(I,15).EQ.13) J=-J
4 RX(I)=RX(I)*10.0**J
X1=RX(1)
C NOW EXECUTE RX(2), OPER, RX(1) -> RX(1)=X1
IF (OPER.GT.31) GO TO 5
IF (OPER.EQ.30) X1=-X1
X1=RX(2)+X1
GO TO 10
5 IF (OPER.EQ.40) GO TO 6
IF (OPER.EQ.60) GO TO 9
X1=RX(2)*X1
GO TO 10
6 IF (X1.NE.0) GO TO 8
7 ERROR=7
RETURN 1
8 X1=RX(2)/X1
GO TO 10
9 IF (RX(2).LE.0.) GO TO 7
X1=X1*ALOG(RX(2))
IF (ABS(X1).GT.174) ERROR=8
IF (ABS(X1).GT.174.) X1=174.*X1/ABS(X1)
X1=EXP(X1)
C EXTRACT EXPONENT, -> A(1,15),..., A(1,17)
10 IF (X1.EQ.0.) GO TO 11
E=ALOG10(ABS(X1))+.00001
GO TO 12
11 K=0
12 IF (E.GE.0) GO TO 13
K=-E+1
X1=X1*10**K
A(1,15)=13
GO TO 14
13 K=E
X1=X1/10**K
A(1,15)=14
14 A(1,16)=K/10
A(1,17)=K-10*A(1,16)
IF (X1.GT.0) GO TO 15
A(1,1)=13
X1=-X1
GO TO 16
15 A(1,1)=14
C CONVERT X1=RX(1) TO A(1,N)
16 A(1,2)=X1
DO 17 I=3,14
J=I-1
X1=10.*(X1-A(1,J))
17 A(1,I)=X1
RETURN
END
SUBROUTINE CLEARX
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (ERROR.NE.0) GO TO 3
OP(1)=0
C THIS STATEMENT IS NUMBERED FOR REFERENCE IN 'CORECT'
1 X(1,1)=15
X(1,2)=15
DO 2 II=3,17
2 X(1,II)=0
3 CALL RESET
RETURN
END
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
SUBROUTINE ADEXPD (ADD, *)
C DATE OF LAST CHANGE - 740520
IMPLICIT INTEGER (A-Z)
LOGICAL ADD
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
C ADD (SUBTRACT) EXPONENT OF D TO (FROM) THAT OF X(1)
J=10*X(1,16)+X(1,17)
IF (X(1,15).EQ.13) J=-J
IF (D(15).EQ.15) D(15)=0
IF (D(16).EQ.15) D(16)=0
K=10*D(15)+D(16)
IF (D(14).EQ.13) K=-K
IF (.NOT.ADD) K=-K
J=J+K
IF (J.GE.0) GO TO 1
J=-J
X(1,15)=13
GO TO 2
1 X(1,15)=14
2 X(1,16)=J/10
X(1,17)=J-X(1,16)*10
IF (X(1,16).LT.10) RETURN
ERROR=8
RETURN 1
END
SUBROUTINE ENTRY
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, JUMP, NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (CODE.EQ.28) GO TO 5
CALL SETUP (&11)
DO 1 I=2,16
1 D(I)=15
2 IF (CODE.GT.10) GO TO 3
CALL DIGIT
GO TO 10
3 IF (CODE.NE.11) GO TO 4
CALL DECPT
GO TO 10
4 IF (CODE.NE.12) GO TO 5
CALL ENTEXP
GO TO 10
5 IF (CODE.NE.28) GO TO 6
CALL CORECT
IF (.NOT.JUMP) GO TO 10
JUMP=.FALSE.
RETURN
6 IF (.NOT.EEX.OR.(CODE.NE.13.AND.CODE.NE.14)) GO TO 7
IF (D(15).EQ.15) D(15)=0
IF (D(16).EQ.15) D(16)=0
J=10*D(15)+D(16)
IF (J.NE.0) GO TO 7
D(14)=CODE
GO TO 10
7 IF (X(1,2).EQ.15) GO TO 8
CALL ADEXPD (.TRUE., &11)
GO TO 9
8 X(1,2)=0
9 NEXT=.TRUE.
C CALL RESET
RETURN
10 IF (ERROR.NE.0) RETURN
CALL CONTRL
GO TO 2
11 RETURN
END
SUBROUTINE DIGIT
C DATE OF LAST CHANGE - 740630
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (.NOT.EEX) GO TO 1
D(15)=D(16)
D(16)=CODE
RETURN
1 IF (M.GT.14) RETURN
IF (DP) GO TO 2
IF (M.EQ.14) RETURN
2 M=M+1
D(M)=CODE
IF (L.GT.13) RETURN
IF (DP) GO TO 3
IF (L.EQ.1) GO TO 4
CALL EXPON (X(1,15),X(1,16),X(1,17),1)
GO TO 5
3 IF (L.NE.1) GO TO 5
CALL EXPON (X(1,15),X(1,16),X(1,17),-1)
4 IF (CODE.EQ.0) RETURN
5 L=L+1
X(1,L)=CODE
RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE EXPON (A,B,C,N)
C DATE OF LAST CHANGE - 740210
C ADD 'N' TO THE EXPONENT 'ABC'
IMPLICIT INTEGER (A-Z)
IF (B.EQ.15) B=0
IF (C.EQ.15) C=0
K=10*B+C
IF (A.EQ.13) K=-K
K=K+N
IF (K.GE.0) GO TO 1
K=-K
A=13
GO TO 2
1 A=14
2 B=K/10
C=K-10*B
RETURN
END
SUBROUTINE DECPT
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (DP) GO TO 1
IF (.NOT.EEX) GO TO 3
1 CALL TESTUP (&5)
IF (D(13).EQ.29) CALL ADEXPD (.TRUE., &4)
OP(1)=50
CALL COLAPS (&4)
CALL ENTRUP (&4)
DO 2 I=2,16
2 D(I)=15
3 DP=.TRUE.
IF (M.GT.13) RETURN
M=M+1
D(M)=11
4 RETURN
5 ERROR=3
RETURN
END
C
C
C
C
SUBROUTINE ENTEXP
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL EEX
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (.NOT.EEX) GO TO 1
CALL TESTUP (&3)
IF (D(13).EQ.29) CALL ADEXPD (.TRUE., &2)
OP(1)=50
CALL COLAPS (&2)
CALL ENTRUP (&2)
D(1)=15
X(1,1)=14
1 D(13)=29
D(14)=15
D(15)=0
D(16)=0
EEX=.TRUE.
IF (M.GT.1) RETURN
D(2)=1
D(3)=11
X(1,2)=1
M=3
2 RETURN
3 ERROR=3
RETURN
END
SUBROUTINE CORECT
C DATE OF LAST CHANGE - 740628
IMPLICIT INTEGER (A-Z)
LOGICAL EEX, DP, JUMP
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (M.EQ.2) GO TO 4
IF (DP) GO TO 5
IF (EEX) GO TO 7
IF (OP(1).NE.0) GO TO 9
IF (L.EQ.2) GO TO 2
IF (L.EQ.1) GO TO 3
CALL EXPON (X(1,15),X(1,16),X(1,17),-1)
1 X(1,L)=0
L=L-1
GO TO 3
2 X(1,2)=15
L=L-1
3 D(M)=15
M=M-1
IF (L.EQ.1) X(1,1)=15
RETURN
C SHOULD 'GO TO' STATEMENT #1 OF CLEARX, BUT IT'S 'CALLED' FOR CONVENIENCE
4 CALL CLEARX
JUMP=.TRUE.
RETURN
5 IF (D(M).NE.11) GO TO 6
DP=.FALSE.
GO TO 3
6 IF (L.GT.2) GO TO 1
CALL EXPON (X(1,15),X(1,16),X(1,17),1)
IF (L.EQ.2) GO TO 2
IF (L.EQ.1) GO TO 3
GO TO 1
7 DO 8 I=13,16
8 D(I)=15
EEX=.FALSE.
RETURN
9 OP(1)=0
IF (D(13).EQ.29) CALL ADEXPD (.FALSE., &10)
JUMP=.TRUE.
10 RETURN
END
SUBROUTINE RECALL
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
LOGICAL START, NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IF (CODE-24) 1, 2, 3
1 REGNO=-3
GO TO 5
2 REGNO=-4
GO TO 6
3 IF (CODE.EQ.25) GO TO 4
REGNO=CODE-40
GO TO 6
4 CALL REG (REGNO)
IF (ERROR.NE.0) RETURN
5 IF (R(REGNO+5,2).NE.15) GO TO 6
ERROR=6
RETURN
6 CALL SETUP (&10)
IF (X(1,1).EQ.13) GO TO 7
CALL TRANS (REGNO,.FALSE.)
GO TO 9
7 CALL TRANS (REGNO,.FALSE.)
IF (X(1,1).EQ.13) GO TO 8
X(1,1)=13
GO TO 9
8 X(1,1)=14
9 CALL UPDATE
10 RETURN
END
SUBROUTINE STORE
C DATE OF LAST CHANGE - 740614
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17), OPCD(19), A(2,17)
COMMON /STACK/ P, X, OP, D
* /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
DATA OPCD /12*0, 30, 31, 0, 40, 41, 0, 60/
KMAX=2
OPCODE=0
1 CALL FINDN (K,KMAX,REGNO)
IF (K.NE.0) GO TO 5
IF (CODE.EQ.25) GO TO 4
IF (CODE.EQ.23) GO TO 3
IF (CODE.GT.12 .AND. CODE.LT.20 .AND.
* CODE.NE.15 .AND. CODE.NE.18) GO TO 2
ERROR=1
RETURN
2 OPCODE=OPCD(CODE)
GO TO 1
3 REGNO=-3
NEXT=.FALSE.
GO TO 7
4 CALL REG (REGNO)
5 IF (REGNO.LE.16) GO TO 6
ERROR=5
RETURN
6 IF (REGNO.GT.0 .OR. REGNO.EQ.-3) GO TO 7
65 ERROR=1
RETURN
C
C 7 IF (X(1,2).NE.15) CALL EQUAL
C IF (ERROR.NE.0) RETURN
C
7 IF (OP(1).GT.1) GO TO 65
OP(1)=1
IF (OPCODE.EQ.0) GO TO 10
K=REGNO+5
DO 8 I=1,17
A(1,I)=X(1,I)
8 A(2,I)=R(K,I)
CALL COMBIN (A, OPCODE, .FALSE., &11)
DO 9 I=1,17
9 R(K,I)=A(1,I)
RETURN
10 CALL TRANS (REGNO,.TRUE.)
11 RETURN
END
SUBROUTINE REG (RN)
C DATE OF LAST CHANGE - 740306
IMPLICIT INTEGER (A-Z)
DIMENSION P(6), X(6,17), OP(6), D(16), INPUT(50), EXPR(50),
* R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
IND=0
KMAX=2
1 CALL FINDN (K,KMAX,RN)
IF (K.NE.0) GO TO 4
IF (CODE.EQ.25) GO TO 3
IF (CODE.EQ.22) GO TO 2
ERROR=9
RETURN
2 RN=16
OP(1)=1
RETURN
3 IND=IND+1
GO TO 1
4 IF (RN.LE.16) GO TO 5
ERROR=5
RETURN
5 IF (IND.EQ.0) RETURN
RN=RN+5
IF (R(RN,2).EQ.15) GO TO 6
RN=(R(RN,2)+0.1*R(RN,3))*10**R(RN,17)
IND=IND-1
GO TO 4
6 ERROR=6
RETURN
END
SUBROUTINE FINDN (K, KMAX, RN)
C DATE OF LAST CHANGE - 740227
IMPLICIT INTEGER (A-Z)
INTEGER INPUT(50), EXPR(50)
LOGICAL NEXT
COMMON /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
K=0
RN=0
1 CALL CONTRL
IF (CODE.GT.10) GO TO 4
K=K+1
KMAX=KMAX-1
IF (K.GT.1) GO TO 2
RN=CODE
GO TO 3
2 RN=10*RN+CODE
3 IF (KMAX.NE.0) GO TO 1
NEXT=.FALSE.
RETURN
4 NEXT=.TRUE.
RETURN
END
C
C
C
C
C
C
C
C
C
C
SUBROUTINE TRANS (REGNO, STORE)
C DATE OF LAST CHANGE - 740101
IMPLICIT INTEGER (A-Z)
LOGICAL STORE
DIMENSION P(6), X(6,17), OP(6), D(16), R(21,17), W(17)
COMMON /STACK/ P, X, OP, D
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
K=REGNO+5
IF (STORE) GO TO 2
DO 1 I=1,17
1 X(1,I)=R(K,I)
RETURN
2 DO 3 I=1,17
3 R(K,I)=X(1,I)
IF (R(K,2).EQ.15) R(K,2)=0
RETURN
END
SUBROUTINE FIXN
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
DIMENSION INPUT(50), EXPR(50), R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
FIXFLG=.TRUE.
CALL NUMBER (&1)
FIX=CODE
CALL UPDATE
1 RETURN
END
C
C
C
C
C
C
C
C
SUBROUTINE SCIN
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL FIXFLG
DIMENSION INPUT(50), EXPR(50), R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
FIXFLG=.FALSE.
CALL NUMBER (&1)
SCI=CODE+1
CALL UPDATE
1 RETURN
END
C
C
C
C
C
C
C
C
SUBROUTINE NUMBER (*)
C DATE OF LAST CHANGE - 740616
IMPLICIT INTEGER (A-Z)
LOGICAL NEXT
DIMENSION INPUT(50), EXPR(50), R(21,17), W(17)
COMMON /FLAGS/ EEX, DP, START, JUMP, NEXT, FIXFLG
* /INPUTS/ INPUT, CODE, EXPR, READ, KEY, NKEYS
* /MISC/ L, M, ERROR, OLD, R, SWITCH, FIX, SCI, W
CALL CONTRL
IF (CODE.LT.11) RETURN
NEXT=.TRUE.
CALL UPDATE
RETURN 1
END